home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / bin / lwp-download.bat < prev    next >
Encoding:
DOS Batch File  |  1999-12-28  |  5.8 KB  |  229 lines
  1. @rem = '--*-Perl-*--
  2. @echo off
  3. perl -x -S %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
  4. goto endofperl
  5. @rem ';
  6. #!perl
  7. #line 8
  8. #perl -w
  9.     eval 'exec perl -S $0 "$@"'
  10.     if 0;
  11.  
  12. # $Id: lwp-download.PL,v 1.2 1996/12/04 14:48:59 aas Exp $
  13.  
  14. =head1 NAME
  15.  
  16. lwp-download - fetch large files from the net
  17.  
  18. =head1 SYNOPSIS
  19.  
  20.  lwp-download <url> [<local file>]
  21.  
  22. =head1 DESCRIPTION
  23.  
  24. The I<lwp-download> program will down load the document specified by the URL
  25. given as the first command line argument to a local file.  The local
  26. filename used to save the document is guessed from the URL unless
  27. specified as the second command line argument.
  28.  
  29. The I<lwp-download> program is implemented using the I<libwww-perl>
  30. library.  It is better suited to down load big files than the
  31. I<lwp-request> program because it does not store the file in memory.
  32. Another benefit is that it will keep you updated about it's progress
  33. and that you don't have any options to worry about.
  34.  
  35. =head1 EXAMPLE
  36.  
  37. Fetch the newest and greatest perl version:
  38.  
  39.  $ lwp-download http://www.perl.com/CPAN/src/latest.tar.gz
  40.  Saving to 'latest.tar.gz'...
  41.  1.47 MB received in 22 seconds (68.7 KB/sec)
  42.  
  43. =head1 AUTHOR
  44.  
  45. Gisle Aas <gisle@aas.no>
  46.  
  47. =cut
  48.  
  49. use LWP::UserAgent;
  50. use LWP::MediaTypes;
  51. use URI::URL;
  52. use strict;
  53.  
  54. $0 =~ s,.*/,,;  # only basename left in progname
  55.  
  56. my $url = url(shift || usage());
  57. my $argfile = shift;
  58.  
  59. my $ua = new LWP::UserAgent;
  60.  
  61. $ua->agent("lwp-download/0.1 " . $ua->agent);
  62.  
  63. my $req = new HTTP::Request GET => $url;
  64.  
  65. my $file;      # name of file we download into
  66. my $length;    # total number of bytes to download
  67. my $flength;   # formatted length
  68. my $size = 0;  # number of bytes received
  69. my $start_t;   # start time of download
  70. my $last_dur;  # time of last callback
  71.  
  72. my $shown = 0; # has we called the show() function yet
  73.  
  74. $SIG{INT} = sub { die "Interrupted\n"; };
  75.  
  76. $| = 1;  # autoflush
  77.  
  78. my $res = $ua->request($req,
  79.   sub {
  80.       unless($file) {
  81.       my $res = $_[1];
  82.       unless ($argfile) {
  83.           # must find a suitable name to use.  First thing
  84.           # to do is to look for the "Content-Disposition"
  85.           # header defined by RFC1806.  This is also supported
  86.           # by Netscape
  87.           my $cd = $res->header("Content-Disposition");
  88.           if ($cd && $cd =~ /\bfilename\s*=\s*(\S+)/) {
  89.           $file = $1;
  90.           $file =~ s/;$//;
  91.           $file =~ s/^([\"\'])(.*)\1$/$2/;
  92.           }
  93.         
  94.           # if this fails we try to make something from the URL
  95.           unless ($file) {
  96.           my $req = $res->request;  # now always there
  97.           my $rurl = $req ? $req->url : $url;
  98.           
  99.           $file = ($rurl->path_components)[-1];
  100.           unless (length $file) {
  101.               $file = "index";
  102.               my $suffix = media_suffix($res->content_type);
  103.               $file .= ".$suffix" if $suffix;
  104.           } elsif ($rurl->scheme eq 'ftp' ||
  105.                $file =~ /\.tgz$/      ||
  106.                $file =~ /\.tar(\.(Z|gz))?$/
  107.               ) {
  108.               # leave the filename as it was
  109.           } else {
  110.               my $ct = guess_media_type($file);
  111.               unless ($ct eq $res->content_type) {
  112.               # need a better suffix for this type
  113.               my $suffix = media_suffix($res->content_type);
  114.               $file .= ".$suffix" if $suffix;
  115.               }
  116.           }
  117.           }
  118.  
  119.           # Check if the file is already present
  120.           if (-f $file && -t) {
  121.           print "Overwrite $file? [y] ";
  122.           my $ans = <STDIN>;
  123.           exit if !defined($ans) || !($ans =~ /^y?\n/);
  124.           } else {
  125.           print "Saving to '$file'...\n";
  126.           }
  127.       } else {
  128.           $file = $argfile;
  129.       }
  130.       open(FILE, ">$file") || die "Can't open $file: $!";
  131.       $length = $res->content_length;
  132.       $flength = fbytes($length) if defined $length;
  133.       $start_t = time;
  134.       $last_dur = 0;
  135.       }
  136.       $size += length($_[0]);
  137.       print FILE $_[0];
  138.       if (defined $length) {
  139.       my $dur  = time - $start_t;
  140.       if ($dur != $last_dur) {  # don't update too often
  141.           $last_dur = $dur;
  142.           my $perc = $size / $length;
  143.           my $speed;
  144.           $speed = fbytes($size/$dur) . "/sec" if $dur > 3;
  145.           my $secs_left = fduration($dur/$perc - $dur);
  146.           $perc = int($perc*100);
  147.           my $show = "$perc% of $flength";
  148.           $show .= " (at $speed, $secs_left remaining)" if $speed;
  149.           show($show);
  150.       }
  151.       } else {
  152.       show( fbytes($size) . " received");
  153.       }
  154.   }
  155. );
  156.  
  157. if ($res->is_success || $res->message =~ /^Interrupted/) {
  158.     show("");  # clear text
  159.     print "\r";
  160.     print fbytes($size);
  161.     print " of ", fbytes($length) if defined($length) && $length != $size;
  162.     print " received";
  163.     my $dur = time - $start_t;
  164.     if ($dur) {
  165.     my $speed = fbytes($size/$dur) . "/sec";
  166.     print " in ", fduration($dur), " ($speed)";
  167.     }
  168.     print "\n";
  169.     my $died = $res->header("X-Died");
  170.     if ($died || !$res->is_success) {
  171.     if (-t) {
  172.         print "Transfer aborted.  Delete $file? [n] ";
  173.         my $ans = <STDIN>;
  174.         unlink($file) if defined($ans) && $ans =~ /^y\n/;
  175.     } else {
  176.         print "Transfer aborted, $file kept\n";
  177.     }
  178.     }
  179. } else {
  180.     print "\n" if $shown;
  181.     print "$0: Can't download: ", $res->code, " ", $res->message, "\n";
  182.     exit 1;
  183. }
  184.  
  185.  
  186. sub fbytes
  187. {
  188.     my $n = int(shift);
  189.     if ($n >= 1024 * 1024) {
  190.     return sprintf "%.3g MB", $n / (1024.0 * 1024);
  191.     } elsif ($n >= 1024) {
  192.     return sprintf "%.3g KB", $n / 1024.0;
  193.     } else {
  194.     return "$n bytes";
  195.     }
  196. }
  197.  
  198. sub fduration
  199. {
  200.     use integer;
  201.     my $secs = int(shift);
  202.     my $hours = $secs / (60*60);
  203.     $secs -= $hours * 60*60;
  204.     my $mins = $secs / 60;
  205.     $secs %= 60;
  206.     if ($hours) {
  207.     return "$hours hours $mins minutes";
  208.     } elsif ($mins >= 2) {
  209.     return "$mins minutes";
  210.     } else {
  211.     $secs += $mins * 60;
  212.     return "$secs seconds";
  213.     }
  214. }
  215.  
  216. sub show
  217. {
  218.     my $mess = shift;
  219.     print "\r$mess", (" " x (75 - length $mess));
  220.     $shown++;
  221. }
  222.  
  223. sub usage
  224. {
  225.     die "Usage: $0 <url> [<lpath>]\n";
  226. }
  227. __END__
  228. :endofperl
  229.